home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / USER2.LSP < prev   
Lisp/Scheme  |  1994-02-05  |  35KB  |  861 lines
  1. ;;;; User-Interface, Teil 2
  2. ;;;; Funktionen fürs Debugging (Kapitel 25.3)
  3. ;;;; Apropos, Describe, Dribble, Ed
  4. ;;;; 27.6.1992
  5.  
  6. (in-package "LISP")
  7. (export '(*editor* editor-tempfile edit-file saveinitmem))
  8. (in-package "SYSTEM")
  9.  
  10. ;-------------------------------------------------------------------------------
  11. ;; APROPOS
  12.  
  13. (defun apropos-list (string &optional (package nil))
  14.   (let* ((L nil)
  15.          (fun #'(lambda (sym)
  16.                   (when
  17.                       #| (search string (symbol-name sym) :test #'char-equal) |#
  18.                       (sys::search-string-equal string sym) ; 15 mal schneller!
  19.                     (push sym L)
  20.                 ) )
  21.         ))
  22.     (if package
  23.       (system::map-symbols fun package)
  24.       (system::map-all-symbols fun)
  25.     )
  26.     (sort L #'string< :key #'symbol-name)
  27. ) )
  28.  
  29. (defun fbound-string (sym) ; liefert den Typ eines Symbols sym mit (fboundp sym)
  30.   (cond ((special-form-p sym)
  31.          #+DEUTSCH "Spezialform"
  32.          #+ENGLISH "special form"
  33.          #+FRANCAIS "forme spéciale"
  34.         )
  35.         ((functionp (symbol-function sym))
  36.          #+DEUTSCH "Funktion"
  37.          #+ENGLISH "function"
  38.          #+FRANCAIS "fonction"
  39.         )
  40.         (t #+DEUTSCH "Macro"
  41.            #+ENGLISH "macro"
  42.            #+FRANCAIS "macro"
  43. ) )     )
  44.  
  45. (defun apropos (string &optional (package nil))
  46.   (dolist (sym (apropos-list string package))
  47.     (print sym)
  48.     (when (fboundp sym)
  49.       (write-string "   ")
  50.       (write-string (fbound-string sym))
  51.     )
  52.     (when (boundp sym)
  53.       (write-string "   ")
  54.       (if (constantp sym)
  55.         (write-string #+DEUTSCH "Konstante"
  56.                       #+ENGLISH "constant"
  57.                       #+FRANCAIS "constante"
  58.         )
  59.         (write-string #+DEUTSCH "Variable"
  60.                       #+ENGLISH "variable"
  61.                       #+FRANCAIS "variable"
  62.   ) ) ) )
  63.   (values)
  64. )
  65.  
  66. ;-------------------------------------------------------------------------------
  67. ;; DESCRIBE
  68.  
  69. (defun describe (obj &optional s &aux (more '()))
  70.   (cond ((eq s 'nil) (setq s *standard-output*))
  71.         ((eq s 't) (setq s *terminal-io*))
  72.   )
  73.   (format s #+DEUTSCH "~%Beschreibung von~%"
  74.             #+ENGLISH "~%Description of~%"
  75.             #+FRANCAIS "~%Description de~%"
  76.   )
  77.   (format s "~A" (write-to-short-string obj sys::*prin-linelength*))
  78.   (format s #+DEUTSCH "~%Das ist "
  79.             #+ENGLISH "~%This is "
  80.             #+FRANCAIS "~%Ceci est "
  81.   )
  82.   (let ((type (type-of obj)))
  83.     ; Dispatch nach den möglichen Resultaten von TYPE-OF:
  84.     (if (atom type)
  85.       (case type
  86.         (CONS
  87.           (flet ((list-length (list)  ; vgl. CLTL, S. 265
  88.                    (do ((n 0 (+ n 2))
  89.                         (fast list (cddr fast))
  90.                         (slow list (cdr slow))
  91.                        )
  92.                        (nil)
  93.                      (when (atom fast) (return n))
  94.                      (when (atom (cdr fast)) (return (1+ n)))
  95.                      (when (eq (cdr fast) slow) (return nil))
  96.                 )) )
  97.             (let ((len (list-length obj)))
  98.               (if len
  99.                 (if (null (nthcdr len obj))
  100.                   (format s #+DEUTSCH "eine Liste der Länge ~S."
  101.                             #+ENGLISH "a list of length ~S."
  102.                             len
  103.                   )
  104.                   (if (> len 1)
  105.                     (format s #+DEUTSCH "eine punktierte Liste der Länge ~S."
  106.                               #+ENGLISH "a dotted list of length ~S."
  107.                               len
  108.                     )
  109.                     (format s #+DEUTSCH "ein Cons."
  110.                               #+ENGLISH "a cons."
  111.                 ) ) )
  112.                 (format s #+DEUTSCH "eine zyklische Liste."
  113.                           #+ENGLISH "a cyclic list."
  114.         ) ) ) ) )
  115.         ((SYMBOL NULL)
  116.           (when (null obj)
  117.             (format s #+DEUTSCH "die leere Liste, "
  118.                       #+ENGLISH "the empty list, "
  119.           ) )
  120.           (format s #+DEUTSCH "das Symbol ~S"
  121.                     #+ENGLISH "the symbol ~S"
  122.                     obj
  123.           )
  124.           (when (keywordp obj)
  125.             (format s #+DEUTSCH ", ein Keyword"
  126.                       #+ENGLISH ", a keyword"
  127.           ) )
  128.           (when (boundp obj)
  129.             (if (constantp obj)
  130.               (format s #+DEUTSCH ", eine Konstante"
  131.                         #+ENGLISH ", a constant"
  132.               )
  133.               (if (sys::special-variable-p obj)
  134.                 (format s #+DEUTSCH ", eine SPECIAL-deklarierte Variable"
  135.                           #+ENGLISH ", a variable declared SPECIAL"
  136.                 )
  137.                 (format s #+DEUTSCH ", eine Variable"
  138.                           #+ENGLISH ", a variable"
  139.             ) ) )
  140.             (push `,obj more)
  141.             (push `(SYMBOL-VALUE ',obj) more)
  142.           )
  143.           (when (fboundp obj)
  144.             (format s #+DEUTSCH ", benennt "
  145.                       #+ENGLISH ", names "
  146.             )
  147.             (cond ((special-form-p obj)
  148.                    (format s #+DEUTSCH "eine Special-Form"
  149.                              #+ENGLISH "a special form"
  150.                    )
  151.                    (when (macro-function obj)
  152.                      (format s #+DEUTSCH " mit Macro-Definition"
  153.                                #+ENGLISH " with macro definition"
  154.                   )) )
  155.                   ((functionp (symbol-function obj))
  156.                    (format s #+DEUTSCH "eine Funktion"
  157.                              #+ENGLISH "a function"
  158.                    )
  159.                    (push `#',obj more)
  160.                    (push `(SYMBOL-FUNCTION ',obj) more)
  161.                   )
  162.                   (t ; (macro-function obj)
  163.                    (format s #+DEUTSCH "einen Macro"
  164.                              #+ENGLISH "a macro"
  165.                   ))
  166.           ) )
  167.           (when (symbol-plist obj)
  168.             (let ((properties
  169.                     (do ((l nil)
  170.                          (pl (symbol-plist obj) (cddr pl)))
  171.                         ((null pl) (nreverse l))
  172.                       (push (car pl) l)
  173.                  )) )
  174.               (format s #+DEUTSCH ", hat die Propert~@P ~{~S~^, ~}"
  175.                         #+ENGLISH ", has the propert~@P ~{~S~^, ~}"
  176.                         (length properties) properties
  177.             ) )
  178.             (push `(SYMBOL-PLIST ',obj) more)
  179.           )
  180.           (format s #+DEUTSCH "."
  181.                     #+ENGLISH "."
  182.           )
  183.           (format s #+DEUTSCH "~%Das Symbol "
  184.                     #+ENGLISH "~%The symbol "
  185.           )
  186.           (let ((home (symbol-package obj)))
  187.             (if home
  188.               (format s #+DEUTSCH "liegt in ~S"
  189.                         #+ENGLISH "lies in ~S"
  190.                         home
  191.               )
  192.               (format s #+DEUTSCH "ist uninterniert"
  193.                         #+ENGLISH "is uninterned"
  194.             ) )
  195.             (let ((accessible-packs nil))
  196.               (let ((normal-printout ; externe Repräsentation ohne Package-Marker
  197.                       (if home
  198.                         (let ((*package* home)) (prin1-to-string obj))
  199.                         (let ((*print-gensym* nil)) (prin1-to-string obj))
  200.                    )) )
  201.                 (dolist (pack (list-all-packages))
  202.                   (when ; obj in pack accessible?
  203.                         (string=
  204.                           (let ((*package* pack)) (prin1-to-string obj))
  205.                           normal-printout
  206.                         )
  207.                     (push pack accessible-packs)
  208.               ) ) )
  209.               (when accessible-packs
  210.                 (format s #+DEUTSCH " und ist in ~:[der Package~;den Packages~] ~{~A~^, ~} accessible"
  211.                           #+ENGLISH " and is accessible in the package~:[~;s~] ~{~A~^, ~}"
  212.                           (cdr accessible-packs)
  213.                           (sort (mapcar #'package-name accessible-packs) #'string<)
  214.           ) ) ) )
  215.           (format s #+DEUTSCH "."
  216.                     #+ENGLISH "."
  217.         ) )
  218.         ((FIXNUM BIGNUM)
  219.           (format s #+DEUTSCH "eine ganze Zahl, belegt ~S Bits, ist als ~:(~A~) repräsentiert."
  220.                     #+ENGLISH "an integer, uses ~S bits, is represented as a ~(~A~)."
  221.                     (integer-length obj) type
  222.         ) )
  223.         (RATIO
  224.           (format s #+DEUTSCH "eine rationale, nicht ganze Zahl."
  225.                     #+ENGLISH "a rational, not integral number."
  226.         ) )
  227.         ((SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT)
  228.           (format s #+DEUTSCH "eine Fließkommazahl mit ~S Mantissenbits (~:(~A~))."
  229.                     #+ENGLISH "a float with ~S bits of mantissa (~(~A~))."
  230.                     (float-digits obj) type
  231.         ) )
  232.         (COMPLEX
  233.           (format s #+DEUTSCH "eine komplexe Zahl "
  234.                     #+ENGLISH "a complex number "
  235.           )
  236.           (let ((x (realpart obj))
  237.                 (y (imagpart obj)))
  238.             (if (zerop y)
  239.               (if (zerop x)
  240.                 (format s #+DEUTSCH "im Ursprung"
  241.                           #+ENGLISH "at the origin"
  242.                 )
  243.                 (format s #+DEUTSCH "auf der ~:[posi~;nega~]tiven reellen Achse"
  244.                           #+ENGLISH "on the ~:[posi~;nega~]tive real axis"
  245.                           (minusp x)
  246.               ) )
  247.               (if (zerop x)
  248.                 (format s #+DEUTSCH "auf der ~:[posi~;nega~]tiven imaginären Achse"
  249.                           #+ENGLISH "on the ~:[posi~;nega~]tive imaginary axis"
  250.                           (minusp y)
  251.                 )
  252.                 (format s #+DEUTSCH "im ~:[~:[ers~;vier~]~;~:[zwei~;drit~]~]ten Quadranten"
  253.                           #+ENGLISH "in ~:[~:[first~;fourth~]~;~:[second~;third~]~] the quadrant"
  254.                           (minusp x) (minusp y)
  255.           ) ) ) )
  256.           (format s #+DEUTSCH " der Gaußschen Zahlenebene."
  257.                     #+ENGLISH " of the Gaussian number plane."
  258.         ) )
  259.         (CHARACTER
  260.           (format s #+DEUTSCH "ein Zeichen"
  261.                     #+ENGLISH "a character"
  262.           )
  263.           (unless (zerop (char-bits obj))
  264.             (format s #+DEUTSCH " mit Zusatzbits"
  265.                       #+ENGLISH " with additional bits"
  266.           ) )
  267.           (unless (zerop (char-font obj))
  268.             (format s #+DEUTSCH " aus Zeichensatz ~S"
  269.                       #+ENGLISH " from font ~S"
  270.                       (char-font obj)
  271.           ) )
  272.           (format s #+DEUTSCH "."
  273.                     #+ENGLISH "."
  274.           )
  275.           (format s #+DEUTSCH "~%Es ist ein ~:[nicht ~;~]druckbares Zeichen."
  276.                     #+ENGLISH "~%It is a ~:[non-~;~]printable character."
  277.                     (graphic-char-p obj)
  278.           )
  279.           (unless (standard-char-p obj)
  280.             (format s #+DEUTSCH "~%Seine Verwendung ist nicht portabel."
  281.                       #+ENGLISH "~%Its use is non-portable."
  282.           ) )
  283.         )
  284.         (FUNCTION ; (SYS::CLOSUREP obj) ist erfüllt
  285.           (let ((compiledp (compiled-function-p obj)))
  286.             (format s #+DEUTSCH "eine ~:[interpret~;compil~]ierte Funktion."
  287.                       #+ENGLISH "a~:[n interpret~; compil~]ed function."
  288.                       compiledp
  289.             )
  290.             (if compiledp
  291.               (multiple-value-bind (req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  292.                   (sys::signature obj)
  293.                 (describe-signature s req-anz opt-anz rest-p key-p keyword-list allow-other-keys-p)
  294.                 (push `(DISASSEMBLE #',(sys::closure-name obj)) more)
  295.                 (push `(DISASSEMBLE ',obj) more)
  296.               )
  297.               (progn
  298.                 (format s #+DEUTSCH "~%Argumentliste: ~S"
  299.                           #+ENGLISH "~%argument list: ~S"
  300.                           (car (sys::%record-ref obj 1))
  301.                 )
  302.                 (let ((doc (sys::%record-ref obj 2)))
  303.                   (when doc
  304.                     (format s #+DEUTSCH "~%Dokumentation: ~A"
  305.                               #+ENGLISH "~%documentation: ~A"
  306.                               doc
  307.               ) ) ) )
  308.         ) ) )
  309.         (COMPILED-FUNCTION ; nur SUBRs und FSUBRs
  310.           (if (functionp obj)
  311.             ; SUBR
  312.             (progn
  313.               (format s #+DEUTSCH "eine eingebaute System-Funktion."
  314.                         #+ENGLISH "a built-in system function."
  315.               )
  316.               (multiple-value-bind (name req-anz opt-anz rest-p keywords allow-other-keys)
  317.                   (sys::subr-info obj)
  318.                 (when name
  319.                   (describe-signature s req-anz opt-anz rest-p keywords keywords allow-other-keys)
  320.             ) ) )
  321.             ; FSUBR
  322.             (format s #+DEUTSCH "ein Special-Form-Handler."
  323.                       #+ENGLISH "a special form handler."
  324.         ) ) )
  325.         (STREAM
  326.           (format s #+DEUTSCH "ein ~:[~:[geschlossener ~;Output-~]~;~:[Input-~;bidirektionaler ~]~]Stream."
  327.                     #+ENGLISH "a~:[~:[ closed ~;n output-~]~;~:[n input-~;n input/output-~]~]stream."
  328.                     (input-stream-p obj) (output-stream-p obj)
  329.         ) )
  330.         (PACKAGE
  331.           (format s #+DEUTSCH "die Package mit Namen ~A"
  332.                     #+ENGLISH "the package named ~A"
  333.                     (package-name obj)
  334.           )
  335.           (let ((nicknames (package-nicknames obj)))
  336.             (when nicknames
  337.               (format s #+DEUTSCH " und zusätzlichen Namen ~{~A~^, ~}"
  338.                         #+ENGLISH ". It has the nicknames ~{~A~^, ~}"
  339.                         nicknames
  340.           ) ) )
  341.           (format s #+DEUTSCH "."
  342.                     #+ENGLISH "."
  343.           )
  344.           (let ((use-list (package-use-list obj))
  345.                 (used-by-list (package-used-by-list obj)))
  346.             (format s #+DEUTSCH "~%Sie "
  347.                       #+ENGLISH "~%It "
  348.             )
  349.             (when use-list
  350.               (format s #+DEUTSCH "importiert die externen Symbole der Package~:[~;s~] ~{~A~^, ~} und "
  351.                         #+ENGLISH "imports the external symbols of the package~:[~;s~] ~{~A~^, ~} and "
  352.                         (cdr use-list) (mapcar #'package-name use-list)
  353.             ) )
  354.             (format s #+DEUTSCH "exportiert ~:[keine Symbole~;die Symbole~:*~{~<~%~:; ~S~>~^~}~]"
  355.                       #+ENGLISH "exports ~:[no symbols~;the symbols~:*~{~<~%~:; ~S~>~^~}~]"
  356.                       ; Liste aller exportierten Symbole:
  357.                       (let ((L nil))
  358.                         (do-external-symbols (s obj) (push s L))
  359.                         (sort L #'string< :key #'symbol-name)
  360.             )         )
  361.             (when used-by-list
  362.               (format s #+DEUTSCH " an die Package~:[~;s~] ~{~A~^, ~}"
  363.                         #+ENGLISH " to the package~:[~;s~] ~{~A~^, ~}"
  364.                         (cdr used-by-list) (mapcar #'package-name used-by-list)
  365.             ) )
  366.             (format s #+DEUTSCH "."
  367.                       #+ENGLISH "."
  368.         ) ) )
  369.         (HASH-TABLE
  370.           (format s #+DEUTSCH "eine Hash-Tabelle mit ~S Eintr~:*~[ägen~;ag~:;ägen~]."
  371.                     #+ENGLISH "a hash table with ~S entr~:@P."
  372.                     (hash-table-count obj)
  373.         ) )
  374.         (READTABLE
  375.           (format s #+DEUTSCH "~:[eine ~;die Common-Lisp-~]Readtable."
  376.                     #+ENGLISH "~:[a~;the Common Lisp~] readtable."
  377.                     (equalp obj (copy-readtable))
  378.         ) )
  379.         (PATHNAME
  380.           (format s #+DEUTSCH "ein Pathname~:[.~;~:*, aufgebaut aus:~{~A~}~]"
  381.                     #+ENGLISH "a pathname~:[.~;~:*, with the following components:~{~A~}~]"
  382.                     (mapcan #'(lambda (kw component)
  383.                                 (when component
  384.                                   (list (format nil "~%~A = ~A"
  385.                                                     (symbol-name kw)
  386.                                                     (make-pathname kw component)
  387.                               ) ) )     )
  388.                       '(:host :device :directory :name :type :version)
  389.                       (list
  390.                         (pathname-host obj)
  391.                         (pathname-device obj)
  392.                         (pathname-directory obj)
  393.                         (pathname-name obj)
  394.                         (pathname-type obj)
  395.                         (pathname-version obj)
  396.         ) )         ) )
  397.         (RANDOM-STATE
  398.           (format s #+DEUTSCH "ein Random-State."
  399.                     #+ENGLISH "a random-state."
  400.         ) )
  401.         (BYTE
  402.           (format s #+DEUTSCH "ein Byte-Specifier, bezeichnet die ~S Bits ab Bitposition ~S eines Integers."
  403.                     #+ENGLISH "a byte specifier, denoting the ~S bits starting at bit position ~S of an integer."
  404.                     (byte-size obj) (byte-position obj)
  405.         ) )
  406.         (LOAD-TIME-EVAL
  407.           (format s #+DEUTSCH "eine Absicht der Evaluierung zur Ladezeit." ; ??
  408.                     #+ENGLISH "a load-time evaluation promise." ; ??
  409.         ) )
  410.         (READ-LABEL
  411.           (format s #+DEUTSCH "eine Markierung zur Auflösung von #~D#-Verweisen bei READ."
  412.                     #+ENGLISH "a label used for resolving #~D# references during READ."
  413.                     (logand (sys::address-of obj) '#,(ash most-positive-fixnum -1))
  414.         ) )
  415.         (FRAME-POINTER
  416.           (format s #+DEUTSCH "ein Pointer in den Stack. Er zeigt auf:"
  417.                     #+ENGLISH "a pointer into the stack. It points to:"
  418.           )
  419.           (sys::describe-frame s obj)
  420.         )
  421.         (SYSTEM-INTERNAL
  422.           (format s #+DEUTSCH "ein Objekt mit besonderen Eigenschaften."
  423.                     #+ENGLISH "a special-purpose object."
  424.         ) )
  425.         (ADDRESS
  426.           (format s #+DEUTSCH "eine Maschinen-Adresse."
  427.                     #+ENGLISH "a machine address."
  428.         ) )
  429.         (t
  430.          (if (and (symbolp type) (sys::%structure-type-p type obj))
  431.            ; Structure
  432.            (progn
  433.              (format s #+DEUTSCH "eine Structure vom Typ ~S."
  434.                        #+ENGLISH "a structure of type ~S."
  435.                        type
  436.              )
  437.              (let ((type (sys::%record-ref obj 0)))
  438.                (when (cdr type)
  439.                  (format s #+DEUTSCH "~%Als solche ist sie auch eine Structure vom Typ ~{~S~^, ~}."
  440.                            #+ENGLISH "~%As such, it is also a structure of type ~{~S~^, ~}."
  441.                            (cdr type)
  442.            ) ) ) )
  443.            ; CLOS-Instanz
  444.            (progn
  445.              (format s #+DEUTSCH "eine Instanz der CLOS-Klasse ~S."
  446.                        #+ENGLISH "an instance of the CLOS class ~S."
  447.                        (clos:class-of obj)
  448.              )
  449.              (clos:describe-object obj s)
  450.          ) )
  451.       ) )
  452.       ; Array-Typen
  453.       (let ((rank (array-rank obj))
  454.             (eltype (array-element-type obj)))
  455.         (format s #+DEUTSCH "ein~:[~; einfacher~] ~A-dimensionaler Array"
  456.                   #+ENGLISH "a~:[~; simple~] ~R dimensional array"
  457.                   (simple-array-p obj) rank
  458.         )
  459.         (when (eql rank 1)
  460.           (format s #+DEUTSCH " (Vektor)"
  461.                     #+ENGLISH " (vector)"
  462.         ) )
  463.         (unless (eq eltype 'T)
  464.           (format s #+DEUTSCH " von ~:(~A~)s"
  465.                     #+ENGLISH " of ~(~A~)s"
  466.                     eltype
  467.         ) )
  468.         (when (adjustable-array-p obj)
  469.           (format s #+DEUTSCH ", adjustierbar"
  470.                     #+ENGLISH ", adjustable"
  471.         ) )
  472.         (when (plusp rank)
  473.           (format s #+DEUTSCH ", der Größe ~{~S~^ x ~}"
  474.                     #+ENGLISH ", of size ~{~S~^ x ~}"
  475.                     (array-dimensions obj)
  476.           )
  477.           (when (array-has-fill-pointer-p obj)
  478.             (format s #+DEUTSCH " und der momentanen Länge (Fill-Pointer) ~S"
  479.                       #+ENGLISH " and current length (fill-pointer) ~S"
  480.                       (fill-pointer obj)
  481.         ) ) )
  482.         (format s #+DEUTSCH "."
  483.                   #+ENGLISH "."
  484.       ) )
  485.   ) )
  486.   (when more
  487.     (format s #+DEUTSCH "~%Mehr Information durch Auswerten von ~{~S~^ oder ~}."
  488.               #+ENGLISH "~%For more information, evaluate ~{~S~^ or ~}."
  489.               (nreverse more)
  490.   ) )
  491.   (values)
  492. )
  493.  
  494. (defun describe-signature (s req-anz opt-anz rest-p keyword-p keywords allow-other-keys)
  495.   (format s #+DEUTSCH "~%Argumentliste: "
  496.             #+ENGLISH "~%argument list: "
  497.   )
  498.   (format s "(~{~A~^ ~})"
  499.     (let ((args '()) (count 0))
  500.       (dotimes (i req-anz)
  501.         (incf count)
  502.         (push (format nil "ARG~D" count) args)
  503.       )
  504.       (when (plusp opt-anz)
  505.         (push '&OPTIONAL args)
  506.         (dotimes (i opt-anz)
  507.           (incf count)
  508.           (push (format nil "ARG~D" count) args)
  509.       ) )
  510.       (when rest-p
  511.         (push '&REST args)
  512.         (push "OTHER-ARGS" args)
  513.       )
  514.       (when keyword-p
  515.         (push '&KEY args)
  516.         (dolist (kw keywords) (push (prin1-to-string kw) args))
  517.         (when allow-other-keys (push '&ALLOW-OTHER-KEYS args))
  518.       )
  519.       (nreverse args)
  520. ) ) )
  521. ;; DOCUMENTATION mit abfragen und ausgeben??
  522. ;; function, variable, type, structure, setf
  523.  
  524. ; Gibt object in einen String aus, der nach Möglichkeit höchstens max Zeichen
  525. ; lang sein soll.
  526. (defun write-to-short-string (object max)
  527.   ; Methode: probiere
  528.   ; level = 0: length = 0,1,2
  529.   ; level = 1: length = 1,2,3,4
  530.   ; level = 2: length = 2,...,6
  531.   ; usw. bis maximal level = 16.
  532.   ; Dabei level möglichst groß, und bei festem level length möglichst groß.
  533.   (if (or (numberp object) (symbolp object)) ; von length und level unbeeinflußt?
  534.     (write-to-string object)
  535.     (macrolet ((minlength (level) `,level)
  536.                (maxlength (level) `(* 2 (+ ,level 1))))
  537.       ; Um level möglist groß zu bekommen, dabei length = minlength wählen.
  538.       (let* ((level ; Binärsuche nach dem richtigen level
  539.                (let ((level1 0) (level2 16))
  540.                  (loop
  541.                    (when (= (- level2 level1) 1) (return))
  542.                    (let ((levelm (floor (+ level1 level2) 2)))
  543.                      (if (<= (length (write-to-string object :level levelm :length (minlength levelm))) max)
  544.                        (setq level1 levelm) ; levelm paßt, probiere größere
  545.                        (setq level2 levelm) ; levelm paßt nicht, probiere kleinere
  546.                  ) ) )
  547.                  level1
  548.              ) )
  549.              (length ; Binärsuche nach dem richtigen length
  550.                (let ((length1 (minlength level)) (length2 (maxlength level)))
  551.                  (loop
  552.                    (when (= (- length2 length1) 1) (return))
  553.                    (let ((lengthm (floor (+ length1 length2) 2)))
  554.                      (if (<= (length (write-to-string object :level level :length lengthm)) max)
  555.                        (setq length1 lengthm) ; lengthm paßt, probiere größere
  556.                        (setq length2 lengthm) ; lengthm paßt nicht, probiere kleinere
  557.                  ) ) )
  558.                  length1
  559.             )) )
  560.         (write-to-string object :level level :length length)
  561. ) ) ) )
  562.  
  563. ;-------------------------------------------------------------------------------
  564. ;; DRIBBLE
  565.  
  566. (let ((dribble-file nil) (dribbled-input nil) (dribbled-output nil))
  567.   (defun dribble (&optional file)
  568.     (if file
  569.       (progn
  570.         (if dribble-file
  571.           (warn #+DEUTSCH "Es wird bereits auf ~S protokolliert."
  572.                 #+ENGLISH "Already dribbling to ~S"
  573.                 #+FRANCAIS "Le protocole est déjà écrit sur ~S."
  574.                 dribble-file
  575.           )
  576.           (setq dribble-file (open file :direction :output)
  577.                 dribbled-input *standard-input*
  578.                 dribbled-output *standard-output*
  579.                 *standard-input* (make-echo-stream *standard-input* dribble-file)
  580.                 *standard-output* (make-broadcast-stream *standard-output* dribble-file)
  581.         ) )
  582.         dribble-file
  583.       )
  584.       (if dribble-file
  585.         (prog2
  586.           (setq *standard-input* dribbled-input
  587.                 *standard-output* dribbled-output
  588.                 dribbled-input nil
  589.                 dribbled-output nil
  590.           )
  591.           dribble-file
  592.           (close dribble-file)
  593.           (setq dribble-file nil)
  594.         )
  595.         (warn #+DEUTSCH "Es wird zur Zeit nicht protokolliert."
  596.               #+ENGLISH "Currently not dribbling."
  597.               #+FRANCAIS "Aucun protocole n'est couramment écrit."
  598. ) ) ) ) )
  599.  
  600. ;-------------------------------------------------------------------------------
  601. ;; ED
  602.  
  603. ;; *editor* und editor-tempfile sind in CONFIG.LSP definiert.
  604. ;; Hier stehen nur die Defaults.
  605.  
  606. ;; Der Name des Editors:
  607. (defparameter *editor* nil)
  608.  
  609. ;; Das temporäre File, das LISP beim Editieren anlegt:
  610. (defun editor-tempfile ()
  611.   #+(or ATARI DOS) "LISPTEMP.LSP"
  612.   #+OS/2 "lisptemp.lsp"
  613.   #+AMIGA "T:lisptemp.lsp"
  614.   #+(or UNIX VMS) (merge-pathnames "lisptemp.lsp" (user-homedir-pathname))
  615. )
  616.  
  617. ;; (edit-file file) editiert ein File.
  618. (defun edit-file (file)
  619.   (unless *editor*
  620.     (error #+DEUTSCH "Kein externer Editor installiert."
  621.            #+ENGLISH "No external editor installed."
  622.            #+FRANCAIS "Un éditeur externe n'est pas installé."
  623.   ) )
  624.   #+ATARI
  625.     (prog1
  626.       (execute *editor* ; das ist der Name des Editors
  627.                (namestring file t) ; file als String, im GEMDOS-Format
  628.                (round (* 0.99 (gc))) ; Editor kriegt 99% des freien Speichers
  629.       )
  630.       (write-string (coerce '(#\Escape #\E) 'string) ; Bildschirm löschen
  631.                     *terminal-io*
  632.     ) )
  633.   #+(or DOS OS/2)
  634.     (execute *editor* ; das ist der Name des Editors
  635.              (namestring file) ; file als String
  636.     )
  637.   #+UNIX
  638.     (shell (format nil "~A ~A" *editor* (truename file)))
  639.   #+AMIGA
  640.     (execute (format nil "~A \"~A\"" *editor* (truename file)))
  641. )
  642.  
  643. (defun ed (&optional arg &aux funname sym fun def)
  644.   (if (null arg)
  645.     (edit-file "")
  646.     (if (or (pathnamep arg) (stringp arg))
  647.       (edit-file arg)
  648.       (if (and (cond ((function-name-p arg) (setq funname arg) t)
  649.                      ((functionp arg) (function-name-p (setq funname (sys::%record-ref arg 0))))
  650.                      (t nil)
  651.                )
  652.                (fboundp (setq sym (get-funname-symbol funname)))
  653.                (or (setq fun (macro-function sym))
  654.                    (setq fun (symbol-function sym))
  655.                )
  656.                (functionp fun)
  657.                (not (compiled-function-p fun))
  658.                (or (function-name-p arg) (eql fun arg))
  659.                (setq def (get sym 'sys::definition))
  660.           )
  661.         (let ((env (vector (sys::%record-ref fun 4) ; venv
  662.                            (sys::%record-ref fun 5) ; fenv
  663.                            (sys::%record-ref fun 6) ; benv
  664.                            (sys::%record-ref fun 7) ; genv
  665.                            (sys::%record-ref fun 8) ; denv
  666.               )    )
  667.               (tempfile (editor-tempfile)))
  668.           (with-open-file (f tempfile :direction :output)
  669.             (pprint def f)
  670.             (terpri f) (terpri f)
  671.           )
  672.           (edit-file tempfile)
  673.           (with-open-file (f tempfile :direction :input)
  674.             (let ((*package* *package*) ; *PACKAGE* binden
  675.                   (end-of-file "EOF")) ; einmaliges Objekt
  676.               (loop
  677.                 (let ((obj (read f nil end-of-file)))
  678.                   (when (eql obj end-of-file) (return))
  679.                   (print (evalhook obj nil nil env))
  680.           ) ) ) )
  681.           funname
  682.         )
  683.         (error #+DEUTSCH "~S ist nicht editierbar."
  684.                #+ENGLISH "~S cannot be edited."
  685.                #+FRANCAIS "~S ne peut pas être édité."
  686.                arg
  687. ) ) ) ) )
  688.  
  689. ;-------------------------------------------------------------------------------
  690.  
  691. ; speichert den momentanen Speicherinhalt unter Weglassen überflüssiger
  692. ; Objekte ab als LISPINIT.MEM
  693. (defun saveinitmem ()
  694.   (do-all-symbols (sym) (remprop sym 'sys::definition))
  695.   (setq - nil + nil ++ nil +++ nil * nil ** nil *** nil / nil // nil /// nil)
  696.   (savemem "lispinit.mem")
  697.   (room)
  698. )
  699.  
  700. ;-------------------------------------------------------------------------------
  701.  
  702. ; Vervollständigungs-Routine in Verbindung mit der GNU Readline-Library:
  703. ; Input: string die Eingabezeile, (subseq string start end) das zu vervoll-
  704. ; ständigende Textstück.
  705. ; Output: eine Liste von Simple-Strings. Leer, falls keine sinnvolle Vervoll-
  706. ; ständigung. Sonst CDR = Liste aller sinnvollen Vervollständigungen, CAR =
  707. ; sofortige Ersetzung.
  708. #+(or UNIX DOS OS/2)
  709. (defun completion (string start end)
  710.   ; quotiert vervollständigen?
  711.   (let ((start1 start) (quoted nil))
  712.     (when (and (>= start 1) (member (char string (- start 1)) '(#\" #\|)))
  713.       (decf start1) (setq quoted t)
  714.     )
  715.     (let (; Hilfsvariablen beim Sammeln der Symbole:
  716.           knownpart ; Anfangsstück
  717.           knownlen  ; dessen Länge
  718.           (L '())   ; sammelnde Liste
  719.          )
  720.       (let ((gatherer
  721.               (if ; Vervollständigung in funktionaler Position?
  722.                 (or (and (>= start1 1)
  723.                          (equal (subseq string (- start1 1) start1) "(")
  724.                     )
  725.                     (and (>= start1 2)
  726.                          (equal (subseq string (- start1 2) start1) "#'")
  727.                 )   )
  728.                 #'(lambda (sym)
  729.                     (when (fboundp sym)
  730.                       (let ((name (symbol-name sym)))
  731.                         (when (and (>= (length name) knownlen) (string-equal name knownpart :end1 knownlen))
  732.                           (push name L)
  733.                   ) ) ) )
  734.                 #'(lambda (sym)
  735.                     (let ((name (symbol-name sym)))
  736.                       (when (and (>= (length name) knownlen) (string-equal name knownpart :end1 knownlen))
  737.                         (push name L)
  738.                   ) ) )
  739.             ) )
  740.             (package *package*)
  741.             (mapfun #'sys::map-symbols)
  742.             (prefix nil))
  743.         ; Evtl. Packagenamen abspalten:
  744.         (unless quoted
  745.           (let ((colon (position #\: string :start start :end end)))
  746.             (when colon
  747.               (unless (setq package (find-package (string-upcase (subseq string start colon))))
  748.                 (return-from completion nil)
  749.               )
  750.               (incf colon)
  751.               (if (and (< colon end) (eql (char string colon) #\:))
  752.                 (incf colon)
  753.                 (setq mapfun #'sys::map-external-symbols)
  754.               )
  755.               (setq prefix (subseq string start colon))
  756.               (setq start colon)
  757.         ) ) )
  758.         (setq knownpart (subseq string start end))
  759.         (setq knownlen (length knownpart))
  760.         (funcall mapfun gatherer package)
  761.         (when (null L) (return-from completion nil))
  762.         (unless quoted
  763.           (setq L (mapcar #'string-downcase L))
  764.         )
  765.         ; sortieren:
  766.         (setq L (sort L #'string<))
  767.         ; größtes gemeinsames Anfangsstück suchen:
  768.         (let ((imax ; (reduce #'min (mapcar #'length L))
  769.                 (let ((i (length (first L))))
  770.                   (dolist (s (rest L)) (setq i (min i (length s))))
  771.                   i
  772.              )) )
  773.           (do ((i 0 (1+ i)))
  774.               ((or (eql i imax)
  775.                    (let ((c (char (first L) i)))
  776.                      (dolist (s (rest L) nil) (unless (eql (char s i) c) (return t)))
  777.                )   )
  778.                (push (subseq (first L) 0 i) L)
  779.         ) )   )
  780.         ; Präfix wieder ankleben:
  781.         (when prefix
  782.           (mapl #'(lambda (l)
  783.                     (setf (car l) (string-concat prefix (car l)))
  784.                   )
  785.                 L
  786.         ) )
  787.         L
  788. ) ) ) )
  789.  
  790. ;-------------------------------------------------------------------------------
  791.  
  792. #+ATARI
  793. ; Unsere eigene kleine "Shell" interpretiert das erste Wort als
  794. ; auszuführendes Programm, den Rest als Argumentzeile.
  795. (defun myshell (command)
  796.   (declare (string command))
  797.   ; Whitespace zu Beginn der Zeile entfernen:
  798.   (let ((index (position-if-not #'whitespacep command)))
  799.     (unless index (return-from myshell))
  800.     (unless (eql index 0) (setq command (subseq command index)))
  801.   )
  802.   ; Nun ist (char command 0) kein Whitespace.
  803.   ; Aufspalten in Programm und Argumentzeile:
  804.   (let* ((index (or (position-if #'whitespacep command) (length command)))
  805.          (prog (subseq command 0 index))
  806.          proglist
  807.          (tail (subseq command
  808.                        (or (position-if-not #'whitespacep command :start index)
  809.                            (length command)
  810.         ))     )       )
  811.     (setq prog (pathname prog))
  812.     (setq proglist
  813.       (if (member :absolute (pathname-directory prog))
  814.         ; relativer Pfadname -> muß Programm im PATH suchen:
  815.         (let* ((pathstring (sys::getenv "PATH"))
  816.                (pathlist ; pathstring an den Strichpunkten aufspalten
  817.                  (and pathstring
  818.                    (let ((i 0) (l '()))
  819.                      (loop
  820.                        (let ((j (position #\; pathstring :start i)))
  821.                          (unless j (push (subseq pathstring i) l) (return))
  822.                          (push (subseq pathstring i j) l)
  823.                          (setq i (+ j 1))
  824.                      ) )
  825.                      (nreverse l)
  826.               )) ) )
  827.           (push "" pathlist) ; aktuelles Directory zuerst
  828.           (setq pathlist (delete-duplicates pathlist :from-end t :test #'equal))
  829.           (setq pathlist
  830.             (mapcar #'(lambda (path)
  831.                         (pathname
  832.                           (if (and (plusp (length path))
  833.                                    (not (eql (char path (1- (length path))) #\\))
  834.                               )
  835.                             (string-concat path "\\")
  836.                             path
  837.                       ) ) )
  838.                     pathlist
  839.           ) )
  840.           (mapcar #'(lambda (path) (merge-pathnames prog path)) pathlist)
  841.         )
  842.         ; absoluter Pfadname -> brauche nicht zu suchen:
  843.         (list prog)
  844.     ) )
  845.     ; Extensions ergänzen:
  846.     (when (null (pathname-type prog))
  847.       (setq proglist
  848.         (mapcan #'(lambda (prog)
  849.                     (list (merge-pathnames prog '#".prg")
  850.                           (merge-pathnames prog '#".ttp")
  851.                           (merge-pathnames prog '#".tos")
  852.                   ) )
  853.                 proglist
  854.     ) ) )
  855.     ; Programm suchen:
  856.     (setq prog (find-if #'probe-file proglist))
  857.     (when prog
  858.       (execute prog tail)
  859. ) ) )
  860.  
  861.